home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / fortran / linpkdrv.zip / SSV.FOR < prev    next >
Text File  |  1984-01-06  |  12KB  |  458 lines
  1. C     MAIN PROGRAM
  2.       INTEGER LUNIT
  3. C     ALLOW 5000 UNDERFLOWS.
  4. C     CALL TRAPS(0,0,5001,0,0)
  5. C
  6. C     OUTPUT UNIT NUMBER
  7. C
  8.       LUNIT = 6
  9. C
  10.       CALL SSVTS(LUNIT)
  11.       STOP
  12.       END
  13.       SUBROUTINE SSVTS(LUNIT)
  14. C     LUNIT IS THE OUTPUT UNIT NUMBER.
  15. C
  16. C     TESTS
  17. C        SSVDC
  18. C
  19. C     LINPACK. THIS VERSION DATED 08/14/78 .
  20. C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
  21. C
  22. C     SUBROUTINES AND FUNCTIONS
  23. C
  24. C     EXTERNAL SMACH,SSVT1,SXGEN
  25. C     FORTRAN FLOAT
  26. C
  27. C     INTERNAL VARIABLES
  28. C
  29.       INTEGER LUNIT
  30.       INTEGER I,J,N,P,LDX,LDU,LDV,CASE,NCASE
  31.       REAL X(25,25),XX(25,25),U(25,25),V(25,25),S(25),E(25),WORK(25)
  32.       REAL SMACH,HUGE,TINY
  33.       LOGICAL NOTWRT
  34.       LDU = 25
  35.       LDV = 25
  36.       LDX = 25
  37.       HUGE = SMACH(3)
  38.       TINY = SMACH(2)
  39.       NOTWRT = .TRUE.
  40.       NCASE = 12
  41.       WRITE (LUNIT,430)
  42.       DO 290 CASE = 1, NCASE
  43.          WRITE (LUNIT,300) CASE
  44.          GO TO (10, 40, 70, 90, 110, 130, 170, 210, 240, 250, 260,
  45.      *          270), CASE
  46. C
  47. C        BIDIAGONAL MATRIX WITH ZERO AT END.
  48. C
  49.    10    CONTINUE
  50.             WRITE (LUNIT,310)
  51.             N = 4
  52.             P = 4
  53.             DO 30 I = 1, 4
  54.                DO 20 J = 1, 4
  55.                   X(I,J) = 0.0E0
  56.    20          CONTINUE
  57.    30       CONTINUE
  58.             X(1,1) = 1.0E0
  59.             X(1,2) = 1.0E0
  60.             X(2,2) = 2.0E0
  61.             X(2,3) = 1.0E0
  62.             X(3,3) = 3.0E0
  63.             X(3,4) = 1.0E0
  64.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  65.      *                 LUNIT,11)
  66.          GO TO 280
  67. C
  68. C        BIDIAGONAL MATRIX WITH ZERO IN THE MIDDLE.
  69. C
  70.    40    CONTINUE
  71.             WRITE (LUNIT,320)
  72.             N = 5
  73.             P = 5
  74.             DO 60 I = 1, 5
  75.                DO 50 J = 1, 5
  76.                   X(I,J) = 0.0E0
  77.    50          CONTINUE
  78.    60       CONTINUE
  79.             X(1,1) = 1.0E0
  80.             X(1,2) = 1.0E0
  81.             X(2,3) = 1.0E0
  82.             X(3,3) = 2.0E0
  83.             X(3,4) = 1.0E0
  84.             X(4,4) = 3.0E0
  85.             X(4,5) = 1.0E0
  86.             X(5,5) = 4.0E0
  87.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,X,LDX,WORK,XX,CASE,NOTWRT,
  88.      *                 LUNIT,11)
  89.          GO TO 280
  90. C
  91. C        TEST CASE WITH N .GT. P.
  92. C
  93.    70    CONTINUE
  94.             WRITE (LUNIT,330)
  95.             N = 8
  96.             P = 4
  97.             DO 80 I = 1, 4
  98.                S(I) = FLOAT(I)
  99.    80       CONTINUE
  100.             CALL SXGEN(X,LDX,N,P,S)
  101.             CALL SSVT1(X,LDX,N,P,S,E,X,LDX,V,LDV,WORK,XX,CASE,NOTWRT,
  102.      *                 LUNIT,21)
  103.          GO TO 280
  104. C
  105. C        TEST CASE WITH N .LT. P.
  106. C
  107.    90    CONTINUE
  108.             WRITE (LUNIT,340)
  109.             N = 4
  110.             P = 8
  111.             DO 100 I = 1, 8
  112.                S(I) = FLOAT(I)
  113.   100       CONTINUE
  114.             CALL SXGEN(X,LDX,N,P,S)
  115.             CALL SSVT1(X,LDX,N,P,S,E,X,LDX,V,LDV,WORK,XX,CASE,NOTWRT,
  116.      *                 LUNIT,11)
  117.          GO TO 280
  118. C
  119. C        TEST CASE WITH N = P = LDX = LDU = LDV.
  120. C
  121.   110    CONTINUE
  122.             WRITE (LUNIT,350)
  123.             N = 25
  124.             P = 25
  125.             DO 120 I = 1, 25
  126.                S(I) = FLOAT(I)
  127.   120       CONTINUE
  128.             CALL SXGEN(X,LDX,N,P,S)
  129.             CALL SSVT1(X,LDX,N,P,S,E,X,LDX,V,LDV,WORK,XX,CASE,NOTWRT,
  130.      *                 LUNIT,11)
  131.          GO TO 280
  132. C
  133. C        TEST FOR OVERFLOW CONTROL.
  134. C
  135.   130    CONTINUE
  136.             WRITE (LUNIT,360)
  137.             N = 4
  138.             P = 8
  139.             DO 140 I = 1, 8
  140.                S(I) = FLOAT(I)
  141.   140       CONTINUE
  142.             CALL SXGEN(X,LDX,N,P,S)
  143.             DO 160 I = 1, 4
  144.                DO 150 J = 1, 8
  145.                   X(I,J) = HUGE*X(I,J)
  146.   150          CONTINUE
  147.   160       CONTINUE
  148.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  149.      *                 LUNIT,11)
  150.          GO TO 280
  151. C
  152. C        TEST FOR UNDERFLOW CONTROL.
  153. C
  154.   170    CONTINUE
  155.             WRITE (LUNIT,370)
  156.             N = 8
  157.             P = 4
  158.             DO 180 I = 1, 8
  159.                S(I) = FLOAT(I)
  160.   180       CONTINUE
  161.             CALL SXGEN(X,LDX,N,P,S)
  162.             DO 200 I = 1, 8
  163.                DO 190 J = 1, 4
  164.                   X(I,J) = TINY*X(I,J)
  165.   190          CONTINUE
  166.   200       CONTINUE
  167.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  168.      *                 LUNIT,11)
  169.          GO TO 280
  170. C
  171. C        ZERO MATRIX.
  172. C
  173.   210    CONTINUE
  174.             WRITE (LUNIT,380)
  175.             N = 8
  176.             P = 4
  177.             DO 230 I = 1, N
  178.                DO 220 J = 1, P
  179.                   X(I,J) = 0.0E0
  180.   220          CONTINUE
  181.   230       CONTINUE
  182.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  183.      *                 LUNIT,11)
  184.          GO TO 280
  185. C
  186. C        1X1 MATRIX.
  187. C
  188.   240    CONTINUE
  189.             WRITE (LUNIT,390)
  190.             N = 1
  191.             P = 1
  192.             X(1,1) = 2.0E0
  193.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  194.      *                 LUNIT,11)
  195.          GO TO 280
  196. C
  197. C        2X2 MATRIX.
  198. C
  199.   250    CONTINUE
  200.             WRITE (LUNIT,400)
  201.             N = 2
  202.             P = 2
  203.             X(1,1) = 3.0E0
  204.             X(1,2) = 1.0E0
  205.             X(2,1) = 1.0E0
  206.             X(2,2) = 2.0E0
  207.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  208.      *                 LUNIT,11)
  209.          GO TO 280
  210. C
  211. C        COLUMN VECTOR.
  212. C
  213.   260    CONTINUE
  214.             WRITE (LUNIT,410)
  215.             N = 4
  216.             P = 1
  217.             X(1,1) = 1.0E0
  218.             X(2,1) = 0.0E0
  219.             X(3,1) = 0.0E0
  220.             X(4,1) = 2.0E0
  221.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  222.      *                 LUNIT,11)
  223.          GO TO 280
  224. C
  225. C        ROW VECTOR.
  226. C
  227.   270    CONTINUE
  228.             WRITE (LUNIT,420)
  229.             N = 1
  230.             P = 4
  231.             X(1,1) = 0.0E0
  232.             X(1,2) = 1.0E0
  233.             X(1,3) = 2.0E0
  234.             X(1,4) = 3.0E0
  235.             CALL SSVT1(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,XX,CASE,NOTWRT,
  236.      *                 LUNIT,11)
  237.   280    CONTINUE
  238.   290 CONTINUE
  239.       WRITE (LUNIT,440)
  240.       RETURN
  241.   300 FORMAT ( / 5H1CASE, I3)
  242.   310 FORMAT ( / 35H BIDIAGONAL MATRIX WITH ZERO AT END)
  243.   320 FORMAT ( / 38H BIDIAGONAL MATRIX WITH ZERO IN MIDDLE)
  244.   330 FORMAT ( / 13H 8 X 4 MATRIX)
  245.   340 FORMAT ( / 13H 4 X 8 MATRIX)
  246.   350 FORMAT ( / 15H 25 X 25 MATRIX)
  247.   360 FORMAT ( / 14H OVERFLOW TEST)
  248.   370 FORMAT ( / 15H UNDERFLOW TEST)
  249.   380 FORMAT ( / 12H ZERO MATRIX)
  250.   390 FORMAT ( / 13H 1 X 1 MATRIX)
  251.   400 FORMAT ( / 13H 2 X 2 MATRIX)
  252.   410 FORMAT ( / 14H COLUMN VECTOR)
  253.   420 FORMAT ( / 11H ROW VECTOR)
  254.   430 FORMAT (22H1LINPACK TESTER, SSV** /
  255.      *        29H THIS VERSION DATED 08/14/78.)
  256.   440 FORMAT ( / 27H1END OF SINGULAR VALUE TEST)
  257.       END
  258.       SUBROUTINE SARRAY(A,LDA,M,N,NNL,LUNIT)
  259.       INTEGER LDA,M,N,NNL,LUNIT
  260.       REAL A(LDA,1)
  261. C
  262. C     FORTRAN IABS,MIN0
  263. C
  264.       INTEGER I,J,K,KU,NL
  265.       NL = IABS(NNL)
  266.       IF (NNL .LT. 0) GO TO 30
  267.          DO 20 I = 1, M
  268.             WRITE (6,70)
  269.             DO 10 K = 1, N, NL
  270.                KU = MIN0(K+NL-1,N)
  271.                WRITE (6,70) (A(I,J), J = K, KU)
  272.    10       CONTINUE
  273.    20    CONTINUE
  274.       GO TO 60
  275.    30 CONTINUE
  276.          DO 50 J = 1, N
  277.             WRITE (6,70)
  278.             DO 40 K = 1, M, NL
  279.                KU = MIN0(K+NL-1,M)
  280.                WRITE (6,70) (A(I,J), I = K, KU)
  281.    40       CONTINUE
  282.    50    CONTINUE
  283.    60 CONTINUE
  284.       RETURN
  285.    70 FORMAT (1H , 8E13.6)
  286.       END
  287.       SUBROUTINE CSVBM(XX,LDX,N,P,S,U,LDU,V,LDV,X,XSTAT)
  288.       INTEGER LDX,N,P,LDU,LDV
  289.       REAL XX(LDX,1),S(1),U(LDU,1),V(LDV,1),X(LDX,1)
  290.       REAL XSTAT
  291. C
  292. C     EXTERNAL SMACH
  293. C     FORTRAN AMAX1,ABS,MIN0
  294. C
  295.       INTEGER I,J,K,M
  296.       REAL T(25)
  297.       REAL SMACH,EMAX,XMAX
  298. C
  299.       M = MIN0(N,P)
  300.       DO 20 J = 1, P
  301.          DO 10 I = 1, M
  302.             X(I,J) = S(I)*V(J,I)
  303.    10    CONTINUE
  304.    20 CONTINUE
  305.       IF (N .LE. P) GO TO 50
  306.          M = P + 1
  307.          DO 40 J = 1, P
  308.             DO 30 I = M, N
  309.                X(I,J) = 0.0E0
  310.    30       C